module XI.Directory.WS.Main where 

import XI.Directory.WS.Xmlable (WsParams(..), Xmlable (..))
import Text.XML.Light.Input(parseXML)
import Text.XML.Light.Output(ppContent)
import Text.XML.Light.Types(Content(..), Element(..), QName(..), Attr(..))
import Text.XML.Light.Proc(onlyElems, elChildren)
import Data.Maybe
import Network.HTTP
import Network.URI
import Data.Typeable
import Data.Time.LocalTime
import qualified Data.Map as Map
import Data.Traversable
import Control.Concurrent.MVar
import Control.Monad

envURI = "http://schemas.xmlsoap.org/soap/envelope/"
		
makeSoapEnvelope :: (Xmlable t) => [(String, String)] -> String -> t -> String
makeSoapEnvelope nss op x = ppContent $
	Elem $ Element
		{
			elName 	  = QName {qName = "Envelope", qURI = Just envURI, qPrefix = Just "soapenv"},
			elAttribs = [Attr {attrKey = QName {qName = "soapenv", qURI = Nothing, qPrefix = Just "xmlns"} , attrVal = envURI}] ++
						[Attr {attrKey = QName {qName = pref, qURI = Nothing, qPrefix = Just "xmlns"} , attrVal = name} |
							(pref, name) <- nss	
						],
			elContent = 
				[
					Elem $ Element
						{
							elName 	  = QName {qName = "Header", qURI = Just envURI, qPrefix = Just "soapenv"},
							elAttribs = [],
							elContent = [],
							elLine = Nothing							
						},
					Elem $ Element
						{
							elName 	  = QName {qName = "Body", qURI = Just envURI, qPrefix = Just "soapenv"},
							elAttribs = [],
							elContent = let Elem e = head $ concat $ toContent x in
								[
									Elem $ Element
										{
											elContent = [Elem e],
											elName = QName {qName = op, qURI = qURI $ elName e, qPrefix = qPrefix $ elName e},
											elAttribs = [],
											elLine = Nothing
										}
								],
							elLine = Nothing							
						}
				],
			elLine = Nothing
		} 
		
wsProxy wspPr = sequenceA (wspPr >>= \fProxy -> return $ 
				catch (readFile fProxy) $ const $ return $ show (Map.empty::(Map.Map String String)))
				>>= return . (>>= return . (read :: String -> Map.Map String String))
					
saveProxy wsp = takeMVar (wspProxyMVar wsp) >>= sequenceA . (>>= return . (writeFile (fromJust $ wspProxy wsp)) . show)

runService :: (Xmlable t1, Xmlable t2) => String -> [(String, String)] -> String -> WsParams -> t1 -> IO t2
runService service nss op wsp x = proxy >>= return . fromContent . (:[]) . map Elem . 
			(>>=elChildren) . (>>=elChildren) . (>>=elChildren) . onlyElems . parseXML
	where
		soapEnv = makeSoapEnvelope nss op x
		runService' = do
			log $ \t -> "\nService " ++ service ++ " (op = " ++ op ++ ") was started at " ++ (show t)
			res <- simpleHTTP (Request (fromJust $ parseURI $ "http://" ++ (wspServer wsp) ++ "/" ++ service ++ "/" ++ (wspProtocolStr wsp))
				POST 
				([
					Header HdrContentLength $ show $ length soapEnv,
					Header HdrUserAgent "XI.Directory.WS",
					Header HdrContentType "text/xml;charset=UTF-8"
				] ++ (map (Header HdrAuthorization) $ maybeToList $ wspAuthorization wsp))
				soapEnv
				)
			log $ \t -> "Service " ++ service ++ " (op = " ++ op ++ ") was finished at " ++ (show t) ++ " " ++ case res of 
					Left err -> "with error: " ++ (show err)
					Right _ -> "successfully"
			return $ case res of
				Left err -> error $ "service " ++ service ++ ": " ++ (show err)
				Right resp -> case (cast $ rspBody resp)::Maybe String of
					Nothing -> error $ "service " ++ service ++ " response body is not a string!"
					Just s -> s

		lock mv = takeMVar $ mv wsp
		unlock mv = putMVar (mv wsp) ()
		log s = lock wspLogMVar >> 
				sequenceA (wspLog wsp >>= \fLog -> return $ getZonedTime >>= appendFile fLog . (++ "\n") . s) >> 
				unlock wspLogMVar
				
		proxy = take >>= (\mp -> 
				if isNothing mp 
					then runS mp >>= \(a, b) -> put a b
					else (\t -> if isNothing t 
						then runS mp >>= \(mp',s) -> put (fmap (Map.insert soapEnv s) mp') s
						else return (fromJust t) >>= put mp) (Map.lookup soapEnv $ fromJust mp))
			where
				put mp s = put0 mp >> return s
				take = takeMVar (wspProxyMVar wsp)
				put0 mp = putMVar (wspProxyMVar wsp) mp
				runS mp = put0 mp >> runService' >>= (\s -> take >>= (\mp' -> return (mp', s)))
				
--runServiceMVar :: (Xmlable t1, Xmlable t2) => String -> [(String, String)] -> String -> WsParams -> t1 -> IO MVar t2
--runServiceMVar service nss op wsp x = proxy >>= return . fromContent . (:[]) . map Elem . 
